home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / ice-9 / syncase.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  7.9 KB  |  241 lines
  1. ;;;;     Copyright (C) 1997, 2000, 2001 Free Software Foundation, Inc.
  2. ;;;; 
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;; 
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16. ;;;; Boston, MA 02111-1307 USA
  17. ;;;;
  18. ;;;; As a special exception, the Free Software Foundation gives permission
  19. ;;;; for additional uses of the text contained in its release of GUILE.
  20. ;;;;
  21. ;;;; The exception is that, if you link the GUILE library with other files
  22. ;;;; to produce an executable, this does not by itself cause the
  23. ;;;; resulting executable to be covered by the GNU General Public License.
  24. ;;;; Your use of that executable is in no way restricted on account of
  25. ;;;; linking the GUILE library code into it.
  26. ;;;;
  27. ;;;; This exception does not however invalidate any other reasons why
  28. ;;;; the executable file might be covered by the GNU General Public License.
  29. ;;;;
  30. ;;;; This exception applies only to the code released by the
  31. ;;;; Free Software Foundation under the name GUILE.  If you copy
  32. ;;;; code from other Free Software Foundation releases into a copy of
  33. ;;;; GUILE, as the General Public License permits, the exception does
  34. ;;;; not apply to the code that you add in this way.  To avoid misleading
  35. ;;;; anyone as to the status of such modified files, you must delete
  36. ;;;; this exception notice from them.
  37. ;;;;
  38. ;;;; If you write modifications of your own for GUILE, it is your choice
  39. ;;;; whether to permit this exception to apply to your modifications.
  40. ;;;; If you do not wish that, delete this exception notice.
  41. ;;;; 
  42.  
  43.  
  44. (define-module (ice-9 syncase)
  45.   :use-module (ice-9 debug)
  46.   :use-module (ice-9 threads)
  47.   :export-syntax (sc-macro define-syntax eval-when fluid-let-syntax
  48.           identifier-syntax let-syntax
  49.           letrec-syntax syntax syntax-case  syntax-rules
  50.           with-syntax
  51.           include)
  52.   :export (sc-expand sc-expand3 install-global-transformer
  53.        syntax-dispatch syntax-error bound-identifier=?
  54.        datum->syntax-object free-identifier=?
  55.        generate-temporaries identifier? syntax-object->datum
  56.        void syncase))
  57.  
  58. ;; This is to avoid a deprecation warning about re-exporting eval.
  59. ;; When the re-exporting behavior of export is removed, removed this
  60. ;; code and include 'eval' in the export clause of define-module,
  61. ;; above.
  62.  
  63. (define eval #f)
  64. (export eval)
  65.  
  66.  
  67.  
  68. (define sc-macro
  69.   (procedure->memoizing-macro
  70.     (lambda (exp env)
  71.       (sc-expand exp))))
  72.  
  73. ;;; Exported variables
  74.  
  75. (define sc-expand #f)
  76. (define sc-expand3 #f)
  77. (define install-global-transformer #f)
  78. (define syntax-dispatch #f)
  79. (define syntax-error #f)
  80.  
  81. (define bound-identifier=? #f)
  82. (define datum->syntax-object #f)
  83. (define define-syntax sc-macro)
  84. (define eval-when sc-macro)
  85. (define fluid-let-syntax sc-macro)
  86. (define free-identifier=? #f)
  87. (define generate-temporaries #f)
  88. (define identifier? #f)
  89. (define identifier-syntax sc-macro)
  90. (define let-syntax sc-macro)
  91. (define letrec-syntax sc-macro)
  92. (define syntax sc-macro)
  93. (define syntax-case sc-macro)
  94. (define syntax-object->datum #f)
  95. (define syntax-rules sc-macro)
  96. (define with-syntax sc-macro)
  97. (define include sc-macro)
  98.  
  99. (define primitive-syntax '(quote lambda letrec if set! begin define or
  100.                   and let let* cond do quasiquote unquote
  101.                   unquote-splicing case))
  102.  
  103. (for-each (lambda (symbol)
  104.         (set-symbol-property! symbol 'primitive-syntax #t))
  105.       primitive-syntax)
  106.  
  107. ;;; Hooks needed by the syntax-case macro package
  108.  
  109. (define (void) *unspecified*)
  110.  
  111. (define andmap
  112.   (lambda (f first . rest)
  113.     (or (null? first)
  114.         (if (null? rest)
  115.             (let andmap ((first first))
  116.               (let ((x (car first)) (first (cdr first)))
  117.                 (if (null? first)
  118.                     (f x)
  119.                     (and (f x) (andmap first)))))
  120.             (let andmap ((first first) (rest rest))
  121.               (let ((x (car first))
  122.                     (xr (map car rest))
  123.                     (first (cdr first))
  124.                     (rest (map cdr rest)))
  125.                 (if (null? first)
  126.                     (apply f (cons x xr))
  127.                     (and (apply f (cons x xr)) (andmap first rest)))))))))
  128.  
  129. (define (error who format-string why what)
  130.   (start-stack 'syncase-stack
  131.            (scm-error 'misc-error
  132.               who
  133.               "~A ~S"
  134.               (list why what)
  135.               '())))
  136.  
  137. (define the-syncase-module (current-module))
  138.  
  139. (define (putprop symbol key binding)
  140.   (let* ((m (current-module))
  141.      (v (or (module-variable m symbol)
  142.         (module-make-local-var! m symbol))))
  143.     (if (symbol-property symbol 'primitive-syntax)
  144.     (if (eq? (current-module) the-syncase-module)
  145.         (set-object-property! (module-variable the-root-module symbol)
  146.                   key
  147.                   binding))
  148.     (variable-set! v sc-macro))
  149.     (set-object-property! v key binding)))
  150.  
  151. (define (getprop symbol key)
  152.   (let* ((m (current-module))
  153.      (v (module-variable m symbol)))
  154.     (and v (or (object-property v key)
  155.            (let ((root-v (module-local-variable the-root-module symbol)))
  156.          (and (equal? root-v v)
  157.               (object-property root-v key)))))))
  158.  
  159. (define generated-symbols (make-weak-key-hash-table 1019))
  160.  
  161. ;; We define our own gensym here because the Guile built-in one will
  162. ;; eventually produce uninterned and unreadable symbols (as needed for
  163. ;; safe macro expansions) and will the be inappropriate for dumping to
  164. ;; pssyntax.pp.
  165. ;;
  166. ;; syncase is supposed to only require that gensym produce unique
  167. ;; readable symbols, and they only need be unique with respect to
  168. ;; multiple calls to gensym, not globally unique.
  169. ;;
  170.  
  171. (define gensym
  172.   (let ((counter 0))
  173.  
  174.     (define next-id
  175.       (if (provided? 'threads)
  176.           (let ((symlock (make-mutex)))
  177.             (lambda ()
  178.               (let ((result #f))
  179.                 (with-mutex symlock
  180.                   (set! result counter)
  181.                   (set! counter (+ counter 1)))
  182.                 result)))
  183.           ;; faster, non-threaded case.
  184.           (lambda ()
  185.             (let ((result counter))
  186.               (set! counter (+ counter 1))
  187.               result))))
  188.     
  189.     ;; actual gensym body code.
  190.     (lambda (. rest)
  191.       (let* ((next-val (next-id))
  192.              (valstr (number->string next-val)))
  193.           (cond
  194.            ((null? rest)
  195.             (string->symbol (string-append "syntmp-" valstr)))
  196.            ((null? (cdr rest))
  197.             (string->symbol (string-append "syntmp-" (car rest) "-" valstr)))
  198.            (else
  199.             (error
  200.              (string-append
  201.               "syncase's gensym expected 0 or 1 arguments, got "
  202.               (length rest)))))))))
  203.  
  204. ;;; Load the preprocessed code
  205.  
  206. (let ((old-debug #f)
  207.       (old-read #f))
  208.   (dynamic-wind (lambda ()
  209.           (set! old-debug (debug-options))
  210.           (set! old-read (read-options)))
  211.         (lambda ()
  212.           (debug-disable 'debug 'procnames)
  213.           (read-disable 'positions)
  214.           (load-from-path "ice-9/psyntax.pp"))
  215.         (lambda ()
  216.           (debug-options old-debug)
  217.           (read-options old-read))))
  218.  
  219.  
  220. ;;; The following lines are necessary only if we start making changes
  221. ;; (use-syntax sc-expand)
  222. ;; (load-from-path "ice-9/psyntax.ss")
  223.  
  224. (define internal-eval (nested-ref the-scm-module '(app modules guile eval)))
  225.  
  226. (define (eval x environment)
  227.   (internal-eval (if (and (pair? x)
  228.               (equal? (car x) "noexpand"))
  229.              (cadr x)
  230.              (sc-expand x))
  231.          environment))
  232.  
  233. ;;; Hack to make syncase macros work in the slib module
  234. (let ((m (nested-ref the-root-module '(app modules ice-9 slib))))
  235.   (if m
  236.       (set-object-property! (module-local-variable m 'define)
  237.                 '*sc-expander*
  238.                 '(define))))
  239.  
  240. (define syncase sc-expand)
  241.